Cream of the Crop 26/Cream of the Crop 26.iso/program/qbsnip.zip/ENVIRON.BAS

BASIC Source File | 1997-06-19 | 16KB | 421 lines

'***********************************************************************
'* MODULE Environ
'*
'* EXTERNAL ROUTINE(S)
'*    QB.LIB
'*       SUB InterruptX (IntNum%, RegsX AS RegTypeX, RegsX AS RegTypeX)
'*
'* CREDIT(S)
'*    Douglas Lusher, Fidonet QuickBASIC, 07-11-94
'*
'* MODIFICATIONS:
'*    Tue, 07-20-94 - Generally cleaned up the code.  Modified the
'*    following routines:
'*
'*       FUNCTION MasterEnvInt$
'*          Removed ERROR statement, added ErrCode% parameter and
'*          assigned unique error codes for each error condition.
'*
'*          Changed "Tmp$ = SPACE$(128)" to "Tmp$ = SPACE(256)" to
'*          support 4DOS which allows environment variables > 128 bytes.
'*          Actually, 4DOS allows environment variables somewhat < 256
'*          bytes, but this is good enough. :)
'*
'*       FUNCTION MasterEnvSet%
'*          Changed from SUB to FUNCTION - ErrCode% parameter no longer
'*          needed.
'*
'*       FUNCTION MasterEnvStr$
'*          Removed ERROR statement, added ErrCode% parameter and
'*          assigned unique error codes for each error condition.
'*
'*          Changed "Tmp$ = SPACE$(128)" to "Tmp$ = SPACE(256)" to
'*          support 4DOS which allows environment variables > 128 bytes.
'***********************************************************************
' additional modifications by Jack Hudgions 02/01/95:
'   changed MasterEnvSet Function as suggested by Mark Northcutt.

DEFINT A-Z

'$INCLUDE: 'qb.bi'

DECLARE FUNCTION MasterEnvFree% ()
DECLARE FUNCTION MasterEnvInt$ (StringNum%, ErrCode%)
DECLARE FUNCTION MasterEnvSeg& ()
DECLARE FUNCTION MasterEnvSet% (Env$)
DECLARE FUNCTION MasterEnvSize% ()
DECLARE FUNCTION MasterEnvStr$ (DefStr$, ErrCode%)
DECLARE SUB ListTable ()

'A demo:
PRINT "Master Environment info:"

PRINT "      Size ="; MasterEnvSize%
PRINT "      Used ="; MasterEnvSize% - MasterEnvFree%
PRINT "      Free ="; MasterEnvFree%
PRINT "   Segment = "; HEX$(MasterEnvSeg&)
PRINT
PRINT "   Current environment variables are:"
DO
   StringNum% = StringNum% + 1
   Environment$ = MasterEnvInt$(StringNum%, ErrCode%)
   IF ErrCode% = 0 THEN
      EqualPtr% = INSTR(Environment$, "=")
      EnvName$ = LEFT$(Environment$, EqualPtr% - 1)
      EnvVal$ = MID$(Environment$, EqualPtr% + 1)

      PRINT "      "; UCASE$(EnvName$)
      PRINT "         "; LEFT$(EnvVal$, 67);

      IF LEN(EnvVal$) > 67 THEN
     PRINT "..."
     PRINT "         ..."; MID$(EnvVal$, 68)
      ELSE
     PRINT
      END IF
   END IF
LOOP UNTIL ErrCode% > 0

PRINT : INPUT "   Enter an environment variable to retrieve: ", DefStr$

Environment$ = MasterEnvStr$(DefStr$, ErrCode)
SELECT CASE ErrCode%
   CASE 0: PRINT "      "; DefStr$; "="; Environment$
   CASE 2: PRINT "      ERROR - you entered a '=' character!"
   CASE 3: PRINT "      ERROR - you entered a NULL character!"
END SELECT
PRINT
INPUT "   Enter an environment variable name to modify: ", EnvName$

IF LEN(EnvName$) THEN
   INPUT "                                Enter new value: ", EnvVal$
   IF LEN(EnvVal$) THEN
      Env$ = EnvName$ + "=" + EnvVal$
      ErrCode% = MasterEnvSet%(Env$)
   END IF
END IF

PRINT : PRINT "Type 'SET' at the DOS prompt to see the new values"
END

'***********************************************************************
'* FUNCTION MasterEnvFree%
'*
'* PURPOSE
'*    Returns the amount of free space in the master environment.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MasterEnvSeg& ()
'*    FUNCTION MasterEnvSize% ()
'***********************************************************************
FUNCTION MasterEnvFree%
   EnvPtr% = -1                              'Pointer into environment

   DEF SEG = MasterEnvSeg&                   'Set segment to Master Env.
   DO
      DO
      EnvPtr% = EnvPtr% + 1                  'Examine next character
      LOOP WHILE PEEK(EnvPtr%)               'Loop until a double NULL
   LOOP WHILE PEEK(EnvPtr% + 1)              '  (terminates the envir.)
   DEF SEG                                   'Restore default segment

   'Assign return value
   MasterEnvFree% = MasterEnvSize% - (EnvPtr% + 2)
END FUNCTION

'***********************************************************************
'* FUNCTION MasterEnvInt$
'*
'* PURPOSE
'*    Returns an environment string specified by StringNum%.
'*
'*    ErrCode% return values:
'*       1  StringNum% < 1
'*       2  StringNum% > the number of environment variables
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MasterEnvSeg& ()
'***********************************************************************
FUNCTION MasterEnvInt$ (StringNum%, ErrCode%)
   MasterEnvInt$ = ""                        'Initialize some variables
   EnvPtr% = -1                              'Pointer into environment
   Count% = 0                                '# of environ. vars. found
   ErrCode% = 0                              'Return value

   IF StringNum% < 1 THEN
      ErrCode% = 1                           'Must be >= 1
      EXIT FUNCTION                          'Bail out
   END IF

   DEF SEG = MasterEnvSeg&                   'Set segment to Master Env.

   DO
      IF PEEK(EnvPtr% + 1) = 0 THEN          'StringNum% > # of
     ErrCode% = 2                            '  environment variables
     EXIT DO                                 'Bail out
      END IF

      Count% = Count + 1                     'Next env. variable
      IF Count% < StringNum% THEN            '
     DO                                      'Find end of current var.
        EnvPtr% = EnvPtr% + 1                'Examine next character
        IF PEEK(EnvPtr%) = 0 THEN            'NULL (end) found
           EXIT DO                           '  exit loop
        END IF
     LOOP
      ELSE                                   'Found specified env. var.
     Tmp$ = SPACE$(256)                      'This is where we'll hold the
                                             '  result
     StrPtr% = 0
     DO                                      'Find end of env. variable
        EnvPtr% = EnvPtr% + 1                'Examine next character
        EnvCh% = PEEK(EnvPtr%)
        IF EnvCh% = 0 THEN                   'Loop until
           EXIT DO                           '  NULL is found
        END IF

        StrPtr% = StrPtr% + 1                'Insert character
        MID$(Tmp$, StrPtr%, 1) = CHR$(EnvCh%)
     LOOP

     MasterEnvInt$ = LEFT$(Tmp$, StrPtr%)    'Assign return value
     EXIT DO
      END IF
   LOOP

   DEF SEG                                   'Restore default segment
END FUNCTION

'***********************************************************************
'* FUNCTION MasterEnvSeg&
'*
'* PURPOSE
'*    Uses (an apparently undocumented) feature of DOS ISR 21H, Function
'*    35H (Get Interrupt Vector) to return the segment of the Master
'*    Environment.
'*
'* EXTERNAL ROUTINE(S)
'*    SUB InterruptX (IntNum%, InReg AS RegTypeX, OutReg AS RegTypeX)
'***********************************************************************
FUNCTION MasterEnvSeg& STATIC
   DIM RegsX AS RegTypeX

   RegsX.ax = &H352E
   INTERRUPTX &H21, RegsX, RegsX

   DEF SEG = RegsX.es
   MasterEnvSeg& = PEEK(&H2C) + PEEK(&H2D) * 256&
   DEF SEG                                   'Restore default segment
END FUNCTION

'***********************************************************************
'* FUNCTION MasterEnvSet%
'*
'* PURPOSE
'*    Sets the specified environment string (Env$) in the master
'*    environment.  Returns 1 if Env$ is empty, if Env$ contains a NULL,
'*    or if Env$ does not contain a "=".  Returns 2 if the result
'*    (after adding/changing Env$) is too long to fit into the maximum
'*    Master Environment size.
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MasterEnvSeg& ()
'*    FUNCTION MasterEnvSize% ()
'***********************************************************************
FUNCTION MasterEnvSet% (Env$)
   null$ = CHR$(0)

   IF LEN(Env$) = 0 THEN                     'Is it set?
      MasterEnvSet% = 1                      '  no, exit
      EXIT FUNCTION                          '  with error
   END IF

   IF INSTR(Env$, null$) THEN                'Does it have a null?
      MasterEnvSet% = 2                      '  Yes, exit
      EXIT FUNCTION                          '  with error.
   END IF

   EqualPtr% = INSTR(Env$, "=")              'Find the "="
   IF EqualPtr% <= 1 THEN                    'Was it found?
      MasterEnvSet% = 3                      '  No, exit
      EXIT FUNCTION                          '  with error
   END IF

   EVar$ = UCASE$(LEFT$(Env$, EqualPtr%))    'Grab the environment name
   EnvVal$ = MID$(Env$, EqualPtr% + 1)       'Grab the environment value

   EnvSize% = MasterEnvSize%
   EnvSeg& = MasterEnvSeg&

   Tmp$ = SPACE$(EnvSize%)
   DEF SEG = EnvSeg&
   FOR EqualPtr% = 1 TO LEN(Tmp$)            'Copy the env. to a string
      MID$(Tmp$, EqualPtr%, 1) = CHR$(PEEK(EqualPtr% - 1))
   NEXT
   DEF SEG                                   'Restore default segment

   'Chop it off at the end of the last environment string
   Tmp$ = LEFT$(Tmp$, INSTR(Tmp$, null$ + null$))

   IF LEN(Tmp$) = 1 THEN                     'If the environment happens
      Tmp$ = ""                              '  to be empty
   END IF

'   EnvVarPtr% = INSTR(Tmp$, EVar$)           'Is Env$ is in the environ?
' Mark's modification begin.
   EnvVarPtr% = INSTR(Tmp$, null$ + EVar$) + 1'Is Env$ is in the environ?
   IF EnvVarPtr% = 0 THEN
       EnvVarPtr% = INSTR(Tmp$, EVar$)        'if null+var is not there,
                                              ' maybe it's (rest cut off)
       IF EnvVarPtr% > 1 THEN EnvVarPtr% = 0  'if not #1 then found a
                                              ' substr later
   END IF
' Mark's modification end.

   IF EnvVarPtr% THEN
      'Find the beginning of the next environment variable
      NextPtr% = INSTR(EnvVarPtr%, Tmp$, null$) + 1

      IF NextPtr% > LEN(Tmp$) THEN           'EVar$ is the last var. in
     Tmp$ = LEFT$(Tmp$, EnvVarPtr% - 1)      '  the environ, so keep
      ELSE                                   '  everything before it.
     'EVar$ isn't the last variable so move everything after it up
     Tmp$ = LEFT$(Tmp$, EnvVarPtr% - 1) + MID$(Tmp$, NextPtr%)
      END IF
   END IF

   IF LEN(EnvVal$) THEN                      'Are we setting it,
      'Add Env$ to the end of the envir. and terminate with two nulls
      Tmp$ = Tmp$ + EVar$ + EnvVal$ + null$ + null$
      IF LEN(Tmp$) > EnvSize% THEN           'Is the result too long?
     MasterEnvSet% = 2                       'Yes, exit with
     EXIT FUNCTION                           '  error
      END IF
   ELSE                                      'Or removing it?
      'If EnvVal$ is empty then all we wanted to do
      '  was remove the variable from the environment
      Tmp$ = Tmp$ + null$

      IF LEN(Tmp$) = 1 THEN                  'If this happened to be the
     Tmp$ = Tmp$ + null$                     '  last environ. var., an
      END IF                                 '  extra null is needed to
   END IF                                    '  terminate.

   DEF SEG = EnvSeg&
   FOR Ptr% = 1 TO LEN(Tmp$)                 'Copy the string back into
      POKE Ptr% - 1, ASC(MID$(Tmp$, Ptr%, 1))'  the environment
   NEXT
   DEF SEG                                   'Restore default segment

   MasterEnvSet% = 0                         'Everything OK
END FUNCTION

'***********************************************************************
'* FUNCTION MasterEnvSize%
'*
'* PURPOSE
'*    Returns the size of the master environment in bytes.
'***********************************************************************
FUNCTION MasterEnvSize%
   DEF SEG = MasterEnvSeg& - 1               'Set segment to Master Env.
   MasterEnvSize% = (PEEK(3) + PEEK(4) * 256) * 16
   DEF SEG                                   'Restore default segment
END FUNCTION

'***********************************************************************
'* FUNCTION MasterEnvStr$
'*
'* PURPOSE
'*    Returns an environment string specified by DefStr$.
'*
'*    ErrCode% return values:
'*       0     Success
'*       1     DefStr$ is empty
'*       2     DefStr$ contains a "="
'*       3     DefStr$ contains an embedded NULL
'*
'* INTERNAL ROUTINE(S)
'*    FUNCTION MasterEnvSeg& ()
'***********************************************************************
FUNCTION MasterEnvStr$ (DefStr$, ErrCode%)
   IF LEN(DefStr$) = 0 THEN
      ErrCode% = 1                           'String is empty
      EXIT FUNCTION                          'Bail out
   END IF

   IF INSTR(DefStr$, "=") THEN
      ErrCode% = 2                           'Invalid environment string
      EXIT FUNCTION                          '  (contains a "="), bail
   END IF                                    '  out.

   IF INSTR(DefStr$, CHR$(0)) THEN
      ErrCode% = 3                           'Invalid environment string
      EXIT FUNCTION                          '  (contains a NULL), bail
   END IF                                    '  out.

   Tmp$ = UCASE$(DefStr$) + "="
   DefLen% = LEN(Tmp$)
   REDIM DefCh%(1 TO DefLen%)                'Fill DefCh%()
   FOR StrPtr% = 1 TO DefLen%                '  with given environ. var.
      DefCh%(StrPtr%) = ASC(MID$(Tmp$, StrPtr%, 1))
   NEXT

   MasterEnvStr$ = ""                        'Initialize some variables
   Found% = 0
   EnvPtr% = -1

   DEF SEG = MasterEnvSeg&                   'Set segment to Master Env.

   DO
      IF PEEK(EnvPtr% + 1) = 0 THEN          'Found terminating NULL
        EXIT DO                              'Bail out
      END IF

      StrPtr% = 0
      DO                                     'Find match for DefStr$
     StrPtr% = StrPtr% + 1                   '  (DefCh%()) in environ.
     IF StrPtr% > DefLen% THEN               'Longer than our env. var.
        GOSUB SkipString                     'It isn't this one,
        EXIT DO                              '  skip it
     END IF

     EnvPtr% = EnvPtr% + 1               'Pointer into environment
     EnvCh% = PEEK(EnvPtr%)              'Get next byte in environ.
     IF EnvCh% = DefCh%(StrPtr%) THEN    'Do the chars. match?
        IF StrPtr% = DefLen% THEN        'Is the length the same?
           Found% = -1                   'Found it!
           EXIT DO                       'Bail out
        END IF
     ELSE
        GOSUB SkipString                 'It isn't this one,
        EXIT DO                          '  skip it
     END IF
      LOOP

      IF Found% THEN                         'If we found it,
     Tmp$ = SPACE$(256)                      'New copy will go here
     StrPtr% = 0
     DO UNTIL EnvCh% = 0                 'Grab the value
        EnvPtr% = EnvPtr% + 1            '  and insert
        EnvCh% = PEEK(EnvPtr%)           '  it in
        StrPtr% = StrPtr% + 1            '  Tmp$
        MID$(Tmp$, StrPtr%, 1) = CHR$(EnvCh%)
     LOOP

     MasterEnvStr$ = LEFT$(Tmp$, StrPtr%)
     EXIT DO
      END IF
   LOOP
   DEF SEG                                   'Restore default segment
   ErrCode% = 0                              'Success
   EXIT FUNCTION                             'All done

SkipString:                                  'Skip current environ. var.
   DO UNTIL EnvCh% = 0                       'Look for terminating NULL
      EnvPtr% = EnvPtr% + 1
      EnvCh% = PEEK(EnvPtr%)
   LOOP
RETURN
END FUNCTION